home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS01.ADF / ABasicStuff / Graphics / FScape.bas < prev    next >
BASIC Source File  |  1985-12-08  |  14KB  |  469 lines
  1. 10    '          Fracscapes
  2. 20    '              or
  3. 30    '    3-D Fractal landscapes
  4. 40    '
  5. 50    '   by Michiel van de Panne
  6. 60    '   From the july issue of Creative Computing (R.I.P.)
  7. 70    '
  8. 80    '    hacked unmercifully and
  9. 90    '   modified for the Amiga from
  10. 100   '   the Mac version by
  11. 110   '   David Milligan, 70707,2521
  12. 120   '   and Ted Ingalls
  13. 130   '         10-19-85
  14. 140   '
  15. 150   '  **  This program will construct a realistic
  16. 160   '  **  3-D landscape fractal from many random numbers
  17. 170   '  **  in up to seven levels of detail, simulating
  18. 180   '  **  mountain ranges, coastlines, sea floor and/or
  19. 190   '  **  surfaces, lakes, islands, etc.
  20. 200   '  **  Once the array used to do the drawing is created,
  21. 210   '  **  it can be saved to disk and reloaded and re-drawn.
  22. 220   '  **  We saved the array rather than the screen because
  23. 230   '  **  (1) we couldn't figure out how to find the start
  24. 240   '  **  of screen memory from ABasiC and couldn't get
  25. 250   '  **  a 640x200 screen stuffed into an array, and
  26. 260   '  **  (2) the array can be re-drawn with different scaling
  27. 270   '  **  factors for perspective changes and with sea level on 
  28. 280   '  **  or off (default is off).
  29. 290   '  **  The length of time required to draw an array depends
  30. 300   '  **  on the number of levels selected. For each increase
  31. 310   '  **  in level the number of triangular subdivisions
  32. 320   '  **  is quadrupled. A level 7 landscape has the highest
  33. 330   '  **  'resolution', but takes over an hour to draw.
  34. 340   '
  35. 350   '  **  One of the main things we added to the original
  36. 360   '  **  program was color. The 12 colors are selected
  37. 370   '  **  by what we determined was altitude to render
  38. 380   '  **  forests, water, snow, dirt, etc.
  39. 390   '  **  Considering we understand vitually nothing
  40. 400   '  **  of the math involved, it works pretty well.
  41. 410   '  **  If you've got a better idea, have at it.
  42. 420   '  **  This program is definately NOT polished,
  43. 430   '  **  optimized or bug free, but it is fun to
  44. 440   '  **  play with.
  45. 450   '  **  While I don't understand them, I find fractal
  46. 460   '  **  graphics generation fascinating. If you've
  47. 470   '  **  got a nifty fractal program, upload it here
  48. 480   '  **  or sing out via E-mail.
  49. 490   '
  50. 500   '           David Milligan, 70707,2521
  51. 510   '
  52. 520   scnclr
  53. 530   '
  54. 540   rem *** Set Screen to 640 x 200 ***
  55. 550   '
  56. 560   ask window wid%,hi%
  57. 570   if wid%<600 then screen 1,4,0
  58. 580   '
  59. 590   '   *** Program Initialization ***
  60. 600   '
  61. 610   dim d(128,65),name$(40):a%=varptr(d(0,0)):l%=33280:le=0
  62. 620   gosub 4450:gosub 690:gosub 770:gosub 3300:goto 2760
  63. 630   '
  64. 640   rem *** Trap Mouse Button ***
  65. 650   '
  66. 660   ask mouse x%,y%,b%:if b%=0 then 660
  67. 670   return
  68. 680   '
  69. 690   rem *** Turn Off Cursor ***
  70. 700   '
  71. 710   rgb 15,0,0,0:return
  72. 720   '
  73. 730   rem *** Turn Cursor on ***
  74. 740   '
  75. 750   rgb 15,11,11,11:return
  76. 760   '
  77. 770   rem *** Set Program Colours ***
  78. 780   '
  79. 790   rgb 0,0,0,0
  80. 800   rgb 1,15,15,15
  81. 810   rgb 3,8,8,8:' light grey
  82. 820   rgb 4,5,5,5:' dark grey
  83. 830   rgb 5,7,4,3:' light brown
  84. 840   rgb 6,6,3,2:' dark brown
  85. 850   rgb 7,0,4,0:' medium green
  86. 860   rgb 8,0,0,12:' light blue
  87. 870   rgb 9,0,0,10:' blue
  88. 880   rgb 10,0,0,7:' medium blue
  89. 890   rgb 11,0,0,4:' dark blue
  90. 900   rgb 12,0,6,0:' green
  91. 910   rgb 13,0,7,0:' light green
  92. 920   rgb 14,0,2,0 :' dark green
  93. 930   return
  94. 940   '
  95. 950   '   *** Calculate array data and insert ***
  96. 960   '
  97. 970   print at (8,3);"Working on Level "
  98. 980   ds=2:for n=1 to le:ds=ds+2^(n-1):next n
  99. 990   mx=ds-1:my=mx/2:rh=pi*30/180:vt=rh*1.2
  100. 1000  for n=1 to le:l=10000/1.8^n
  101. 1010  print at (26,3);n
  102. 1020  ib=mx/2^n:sk=ib*2
  103. 1030  randomize -1
  104. 1040  gosub 1120:rem Assign heights along x in array
  105. 1050  gosub 1210:rem *** Assign heights along Y ***
  106. 1060  gosub 1300:rem *** Assign heights along Z ***
  107. 1070  next n
  108. 1080  scnclr:goto 2680
  109. 1090  '
  110. 1100  '   *** Heights along X ***
  111. 1110  '
  112. 1120  for ye=0 to mx-1 step sk
  113. 1130  for xe=ib+ye to mx step sk
  114. 1140  ax=xe-ib:ay=ye:gosub 1400:d1=d:ax=xe+ib:gosub 1400:d2=d
  115. 1150  d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470
  116. 1160  next xe
  117. 1170  next ye:return
  118. 1180  '
  119. 1190  rem *** Heights along Y ***
  120. 1200  '
  121. 1210  for xe=mx to 1 step -sk
  122. 1220  for ye=ib to xe step sk
  123. 1230  ax=xe:ay=ye+ib:gosub 1400:d1=d:ay=ye-ib:gosub 1400:d2=d
  124. 1240  d=(d1+d2)/2+rnd(1)*l/2-l/4:ax=xe:ay=ye:gosub 1470
  125. 1250  next ye
  126. 1260  next xe:return
  127. 1270  '
  128. 1280  rem *** Heights along Z ***
  129. 1290  '
  130. 1300  for xe=0 to mx-1 step sk
  131. 1310  for ye=ib to mx-xe step sk
  132. 1320  ax=xe+ye-ib:ay=ye-ib:gosub 1400:d1=d
  133. 1330  ax=xe+ye+ib:ay=ye+ib:gosub 1400:d2=d
  134. 1340  ax=xe+ye:ay=ye:d=(d1+d2)/2+rnd(1)*l/2-l/4:gosub 1470
  135. 1350  next ye
  136. 1360  next xe:return
  137. 1370  '
  138. 1380  rem *** Return data from array ***
  139. 1390  '
  140. 1400  if ay>my then 1420
  141. 1410  by=ay:bx=ax:goto 1430
  142. 1420  by=mx+1-ay:bx=mx-ax
  143. 1430  d=d(bx,by):return
  144. 1440  '
  145. 1450  rem *** Put data into array ***
  146. 1460  '
  147. 1470  if ay>my then 1490
  148. 1480  by=ay:bx=ax:goto 1500
  149. 1490  by=mx+1-ay:bx=mx-ax
  150. 1500  d(bx,by)=d:return
  151. 1510  '
  152. 1520  rem *** Sea level section ***
  153. 1530  '
  154. 1540  if sealevel=0 then gosub 1750:return
  155. 1550  if xo<>-999 then 1580
  156. 1560  if zz<0 then gosub 2010:z2=zz:zz=0:goto 1740
  157. 1570  gosub 2050:goto 1730
  158. 1580  if z2>0 and zz>0 then gosub 1750:goto 1730
  159. 1590  if z2<0 and zz<0 then z2=zz:zz=0:goto 1740
  160. 1600  w3=zz/(zz-z2):x3=(x2-xx)*w3+xx:y3=(y2-yy)*w3+yy:z3=0
  161. 1610  zt=zz:yt=yy:xt=xx
  162. 1620  if zz>0 then 1710
  163. 1630  '
  164. 1640  rem *** Going into water ***
  165. 1650  '
  166. 1660  zz=z3:yy=y3:xx=x3:gosub 2320
  167. 1670  gosub 2010:zz=0:yy=yt:xx=xt:z2=zt:goto 1740
  168. 1680  '
  169. 1690  rem *** Coming out of water ***
  170. 1700  '
  171. 1710  zz=z3:yy=y3:xx=x3:gosub 2320
  172. 1720  gosub 2050:zz=zt:yy=yt:xx=xt
  173. 1730  z2=zz
  174. 1740  x2=xx:y2=yy:return
  175. 1750  '
  176. 1760  '  *** New Color Subroutine ***
  177. 1770  '
  178. 1780  if zz<0 then goto 1890
  179. 1790  if zz>950 then pena 2:return
  180. 1800  if zz>850 then pena 3:return
  181. 1810  if zz>750 then pena 4:return
  182. 1820  if zz>650 then pena 5:return
  183. 1830  if zz>550 then pena 6:return
  184. 1840  if zz>450 then pena 13:return
  185. 1850  if zz>350 then pena 12:return
  186. 1860  if zz>100 then pena 7:return
  187. 1870  gosub 2050
  188. 1880  return
  189. 1890  '
  190. 1900  '  *** below sea level ***
  191. 1910  '
  192. 1920  if zz>-200 then gosub 2010:return
  193. 1930  if zz>-500 then pena 9:return
  194. 1940  if zz>-800 then pena 10:return
  195. 1950  if zz>-1200 then pena 11:return
  196. 1960  pena 11
  197. 1970  return
  198. 1980  '
  199. 1990  rem *** Switch to sea level color ***
  200. 2000  '
  201. 2010  pena 8:f1=1:return
  202. 2020  '
  203. 2030  rem *** Switch to land color ***
  204. 2040  '
  205. 2050  pena 14
  206. 2060  f1=0:return
  207. 2070  '
  208. 2080  '   *** Rotation ***
  209. 2090  '
  210. 2100  if xx<>0 then 2130
  211. 2110  if yy<=0 then ra=-pi/2:goto 2150
  212. 2120  ra=pi/2:goto 2150
  213. 2130  ra=atn(yy/xx)
  214. 2140  if xx<0 then ra=ra+pi
  215. 2150  r1=ra+rh:rd=sqr(xx*xx+yy*yy)
  216. 2160  xx=rd*cos(r1):yy=rd*sin(r1)
  217. 2170  return
  218. 2180  '
  219. 2190  rem *** Tilt down ***
  220. 2200  '
  221. 2210  rd=sqr(zz*zz+xx*xx)
  222. 2220  if xx=0 then ra=pi/2:goto 2250
  223. 2230  ra=atn(zz/xx)
  224. 2240  if xx<0 then ra=ra+pi
  225. 2250  r1=ra-vt
  226. 2260  xx=rd*cos(r1)+xx:zz=rd*sin(r1)
  227. 2270  return
  228. 2280  '
  229. 2290  rem *** Plot to (xp,yp) ***
  230. 2300  '
  231. 2310  gosub 1540
  232. 2320  xx=xx*xs:yy=yy*ys:zz=zz*zs
  233. 2330  gosub 2100:rem *** Rotate ***
  234. 2340  gosub 2210:rem *** Tilt up ***
  235. 2350  if xo=-999 then pr$="M" else pr$="D"
  236. 2360  xp=int(yy)+cx:yp=int(zz)
  237. 2370  gosub 2400
  238. 2380  return
  239. 2390  '
  240. 2400  rem *** do plotting here ***
  241. 2410  '
  242. 2420  ask mouse x%,y%,b%:if b%<>0 then 2760
  243. 2430  xp=xp*1.38:yp=48.53-0.663*yp:if pr$="M" then x8=xp:y8=yp
  244. 2440  draw (x8,y8 to xp,yp):x8=xp:y8=yp:xo=xp
  245. 2450  return
  246. 2460  '
  247. 2470  rem *** Plot X Axis ***
  248. 2480  '
  249. 2490  for ax=0 to mx:xo=-999:for ay=0 to ax
  250. 2500  gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2
  251. 2510  gosub 2310:next ay:next ax
  252. 2520  return
  253. 2530  '
  254. 2540  rem *** Plot Y Axis ***
  255. 2550  '
  256. 2560  for ay=0 to mx:xo=-999:for ax=ay to mx
  257. 2570  gosub 1400:zz=d:yy=ay/mx*10000:xx=ax/mx*10000-yy/2
  258. 2580  gosub 2310:next ax:next ay
  259. 2590  return
  260. 2600  '
  261. 2610  rem *** Plot Z Axis ***
  262. 2620  '
  263. 2630  for ex=0 to mx:xo=-999:for ey=0 to mx-ex
  264. 2640  ax=ex+ey:ay=ey:gosub 1400:zz=d:yy=ay/mx*10000
  265. 2650  xx=ax/mx*10000-yy/2:gosub 2310:next ey:next ex
  266. 2660  return
  267. 2670  '
  268. 2680  '   *** Setup Screen ***
  269. 2690  '
  270. 2700  close 2:cmd 1:graphic(1):gosub 760
  271. 2710  tax=ax:tay=ay
  272. 2720  gosub 2630
  273. 2730  gosub 2560
  274. 2740  gosub 2490
  275. 2750  '
  276. 2760  rem *** Main Menu Section ***
  277. 2770  '
  278. 2780  gosub 3370
  279. 2790  print at(4,2);"-> Use Keyboard to Select <-"
  280. 2800  print at(6,4);"1 - Start New Landscape"
  281. 2810  ? at(6,5);"2 - Draw Existing Array"
  282. 2820  ? at(6,6);"3 - Save Fractal Array"
  283. 2830  ? at(6,7);"4 - Load Fractal Array"
  284. 2840  ? at(6,8);"5 - Reset Scaling Factors"
  285. 2850  ? at(6,9);"6 - Set Sea Level Options"
  286. 2860  rem ? at(6,10);"7 - Read & Display Mouse x,y"
  287. 2870  ? at(6,11);"7 - Close This Window !"
  288. 2880  ? at(10,12);"Click the Left Button"
  289. 2890  ? at(10,13);"To Restore Menu"
  290. 2900  ? at(6,14);"0 - Exit to ABasiC"
  291. 2910  pena 0:gosub 4500
  292. 2920  print at(10,16);"Selection (0-8) ";:input a$
  293. 2930  query=val(a$):print at(10,16);spc(20):erase a$
  294. 2940  on query goto 3120,4140,3650,3760,4240,4010,4000,4000,4000
  295. 2950  '
  296. 2960  rem *** Program exit ***
  297. 2970  '
  298. 2980  scnclr:close 3
  299. 2990  cmd 1:scnclr:close 1
  300. 3000  cmd 0:pena 0
  301. 3010  '
  302. 3020  rem *** Restore ABasiC's colours ***
  303. 3030  '
  304. 3040  rgb 0,6,9,15
  305. 3050  rgb 1,0,0,0
  306. 3060  rgb 2,15,15,15
  307. 3070  gosub 750
  308. 3080  clr:end
  309. 3090  '
  310. 3100  rem *** Start a new fractal screen ***
  311. 3110  '
  312. 3120  scnclr:close 3
  313. 3130  '
  314. 3140  rem *** New landscape ***
  315. 3150  '
  316. 3160  cmd 1:graphic(1):scnclr
  317. 3170  gosub 3330
  318. 3180  '
  319. 3190  rem *** Prompt to begin drawing ***
  320. 3200  '
  321. 3210  print at(2,2);"Click the Left Mouse Button to Start."
  322. 3220  print at(4,4);"Click While Drawing to Abort."
  323. 3230  gosub 660:scnclr
  324. 3240  print at(8,3);"Number of levels ";:input le
  325. 3250  scnclr:if le<1 or le>7 then 3240
  326. 3260  goto 950
  327. 3270  '
  328. 3280  rem *** Windows ***
  329. 3290  '
  330. 3300  window #1,0,0,639,199,"Fracscapes"
  331. 3310  return
  332. 3320  '
  333. 3330  window #2,120,50,340,60,"New Fracscape"
  334. 3340  cmd #2:graphic(0):scnclr
  335. 3350  return
  336. 3360  '
  337. 3370  window #3,100,20,300,160,"Main Menu"
  338. 3380  cmd 3:graphic(0):scnclr
  339. 3390  return
  340. 3400  '
  341. 3410  window #4,100,50,400,40,"Save Array"
  342. 3420  cmd 4:graphic(0):scnclr
  343. 3430  return
  344. 3440  '
  345. 3450  window #5,100,100,400,40,"Load Array"
  346. 3460  cmd 5:graphic(0):scnclr
  347. 3470  return
  348. 3480  '
  349. 3490  window #6,100,20,340,130,"Array Description"
  350. 3500  cmd 6:graphic(0):scnclr
  351. 3510  return
  352. 3520  '
  353. 3530  window #7,100,30,340,60,"Sea Level Options"
  354. 3540  cmd 7:graphic(0):scnclr
  355. 3550  return
  356. 3560  '
  357. 3570  window #8,50,20,340,50,"Draw Array in Memory"
  358. 3580  cmd 8:graphic(0)
  359. 3590  return
  360. 3600  '
  361. 3610  window #9,150,30,300,130,"Scaling Settings"
  362. 3620  cmd 9:graphic(0)
  363. 3630  return
  364. 3640  '
  365. 3650  rem *** screen save ***
  366. 3660  '
  367. 3670  on error goto 4540
  368. 3680  gosub 3410:name$=""
  369. 3690  print at(2,2);"Save Array as -> ";:line input name$
  370. 3700  d(0,65)=le:d(1,65)=mx:d(2,65)=my:d(3,65)=tax:d(4,65)=tay
  371. 3710  d(5,65)=xs:d(6,65)=ys:d(7,65)=zs:d(8,65)=sealevel
  372. 3720  bsave name$,a%,l%
  373. 3730  scnclr:close 4:cmd 3
  374. 3740  goto 4110
  375. 3750  '
  376. 3760  rem *** Screen Load ***
  377. 3770  '
  378. 3780  ' on error goto 5000
  379. 3790  gosub 3450:name$=""
  380. 3800  print at(2,2);"Name of Array to Load -> ";:line input name$
  381. 3810  bload name$,a%
  382. 3820  le=d(0,65):mx=d(1,65):my=d(2,65):ax=d(3,65):ay=d(4,65)
  383. 3830  xs=d(5,65):ys=d(6,65):zs=d(7,65):sealevel=d(8,65)
  384. 3840  scnclr:close 5
  385. 3850  gosub 3490
  386. 3860  ? at(7,2);"Array name -> ";name$
  387. 3870  ? at(7,4);"Number of Levels -> ";le
  388. 3880  if sealevel=0 then level$="off" else level$="on"
  389. 3890  ? at(7,6);"Sea Level Display -> ";level$
  390. 3900  ? at(7,8);"Scaling Values ->  X= ";xs
  391. 3910  ? at(26,9);"Y= ";ys
  392. 3920  ? at(26,10);"Z= ";zs
  393. 3930  ? at(5,13);"Click left button to continue"
  394. 3940  gosub 640
  395. 3950  scnclr:close #6:cmd 3
  396. 3960  goto 4110
  397. 3970  '
  398. 3980  rem *** Turn off menu window ***
  399. 3990  '
  400. 4000  scnclr:close 3:gosub 660:goto 2760
  401. 4010  '
  402. 4020  ' **** Set Sea Level Option ****
  403. 4030  '
  404. 4040  gosub 3530
  405. 4050  print at (2,3);"Display sea level surface (Y/N) ";:input a$
  406. 4060  if a$="y" or a$="Y" then sealevel=1 else sealevel=0:goto 4070
  407. 4070  scnclr:close 7:cmd 3
  408. 4080  '
  409. 4090  '  ***  Error Trap ***
  410. 4100  '
  411. 4110  on error goto 4540
  412. 4120  query=0:erase a$
  413. 4130  goto 2920
  414. 4140  '
  415. 4150  ' *** Redraw old Array ***
  416. 4160  '
  417. 4170  if le=0 then 2920
  418. 4180  gosub 3570
  419. 4190  print at(2,2);"Clear Screen Before Re-Draw (Y/N) ";:input a$
  420. 4200  scnclr:close 8:cmd 3:scnclr:close 3:cmd 1:graphic(1)
  421. 4210  if a$="y" or a$="Y" then scnclr
  422. 4220  erase a$:goto 2700
  423. 4230  '
  424. 4240  ' *** Scaling Settings ***
  425. 4250  '
  426. 4260  gosub 3610
  427. 4270  graphic(0)
  428. 4280  print at(5,2);"Current Scaling Settings :"
  429. 4290  print at(13,4);"X= ";xs
  430. 4300  print at(13,5);"Y= ";ys
  431. 4310  print at(13,6);"Z= ";zs
  432. 4320  print at(5,8);"Press C to Change Settings"
  433. 4330  print at(11,9);"D for Default Settings"
  434. 4340  print at(11,10);"X to Exit"
  435. 4350  gosub 4500
  436. 4360  print at(13,12);"Selection ";:input a$
  437. 4370  if a$="c" or a$="C" then 4420
  438. 4380  if a$="d" or a$="D" then gosub 4460:goto 4410
  439. 4390  if a$<>"x" and a$<>"X" then 4410
  440. 4400  scnclr:close 9:cmd 3:goto 4110
  441. 4410  scnclr:erase a$:goto 4280
  442. 4420  print at(13,12);spc(16)
  443. 4430  print at(4,12);"Input New X,Y,Z ";:input xs,ys,zs
  444. 4440  goto 4410
  445. 4450  '
  446. 4460  ' *** Stock Scaling Factors ***
  447. 4470  '
  448. 4480  xs=.04:ys=.04:zs=.05:return
  449. 4490  '
  450. 4500  for i=0 to 10
  451. 4510  get a$:erase a$:next i
  452. 4520  on error goto 4540
  453. 4530  return
  454. 4540  '
  455. 4550  '
  456. 4560  '    **** error trap ****
  457. 4570  '
  458. 4580  '
  459. 4590  fmem%=fre
  460. 4600  window #10,100,100,300,90,"Rats - An Error Occurred"
  461. 4610  cmd #10:graphic(0):scnclr
  462. 4620  ?at(2,2);"Error # ";err;" occurred at line ";erl
  463. 4630  ?at(2,4);err$(err)
  464. 4640  ?at(2,5);"There are ";fmem%;" bytes of memory showing"
  465. 4650  ?at(2,7);"Click left button to continue...."
  466. 4660  gosub 640
  467. 4670  scnclr:close 10,3,4,5,6
  468. 4680  goto 2760
  469.